home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_pas / mkscren2 / scrnctrl.pas < prev    next >
Pascal/Delphi Source File  |  1987-12-08  |  10KB  |  288 lines
  1.  
  2. {procedure that centers a string on the crt screen
  3.  variable description:
  4.  Y : line on screen to center text on
  5.  str : character string to center on the screen
  6. }
  7. PROCEDURE crt_center(Y : integer;str : str80);
  8. begin
  9. gotoXY ((80-length(str)) div 2,Y);
  10. write(str);
  11. end;
  12.  
  13. procedure draw_title;
  14. begin
  15. clrscr;
  16. bold_on;crt_center(1,'Fisher Guide Industrial Engineering Activity');bold_off;
  17. crt_center(2,'M a n u f a c t u r i n g   C o s t   E s t i m a t e');
  18. bold_on;crt_center(3,'Pre-Processing System');bold_off;
  19. end;
  20.  
  21. {function that fills a string with specified number of characters
  22.  variable description:
  23.  cstr : character variable containing fill character
  24.  qty : integer value for quantity of characters to fill
  25.  fillstr : working string variable temporarily holding result
  26. }
  27. function fillstring(cstr : char;qty : integer) : str80;
  28. var fillstr : str80;
  29. begin
  30.  if qty < 0 then qty := 0;
  31.  fillstr[0] := chr(qty);
  32.  fillchar(fillstr[1],qty,cstr);
  33.  fillstring := fillstr;
  34. end;
  35.  
  36. {procedure that draws an entire field definition on the screen
  37.  x : beginning horizontal position of label on the screen
  38.  y : beginning vertical position of label on screen
  39.  xf : returns horizontal beginning of field
  40.  yf : returns vertical position of field
  41.  str : the variable containing the lable to be printed
  42.  flg : a flag 0 for normal print 1 for bold printing of label
  43.  fw : the field width of the input field for this label
  44. }
  45. procedure draw_field(x,y : integer;var xf,yf : integer;str1,str2 : str80;flg,fw : integer);
  46. begin
  47. if (flg = 1) then bold_on;
  48. gotoxy(x,y);write(output,str1,' ');
  49. bold_off;
  50. reverse_on;
  51. write(str2,fillstring(' ',fw-length(str2)));
  52. {write(output,fillstring(' ',fw));}
  53. reverse_off;
  54. yf := y;
  55. xf := x + length(str1) + 1;
  56. end;
  57.  
  58. {procedure that locates a field and allows editing of input data
  59.  s : string that is entered into current field (returned)
  60.  l : length of field
  61.  x : x coordinate of field w.r.t. to screen
  62.  y : y coordinate of field w.r.t. to screen
  63.  term : valid control characters allowed (set variable)
  64.  tc : last command entered (returned to caller)
  65.  dp : Display cursor position within field (0=no,1=yes)
  66.  underscore : constant variable containing terminal underscore
  67.  position : holds current position cursor is at within field
  68.  inchar : holds character or command typed in at console
  69. }
  70. procedure get_field(var s : str80;l,x,y : integer;term : charset;var tc : char;dp : integer);
  71. const
  72.  underscore = '_';
  73. var
  74.  position : integer;
  75.  inchar : char;
  76.  ins : boolean;
  77.  
  78. function get_char : char;
  79. begin
  80.  result.ax := $0700;
  81.  Msdos(result);
  82.  get_char := chr(result.ax and $00FF);
  83. end;
  84.  
  85. begin
  86.  reverse_on;
  87.  gotoxy(x,y);write(s,fillstring(underscore,l-length(s)));
  88.  position := 0;
  89.  ins := false;
  90.  gotoxy(73,24);write('OVR');
  91.  repeat
  92.   if (dp = 1) then begin gotoxy(26,10);write(position+1:2);end;
  93.   gotoxy(x+position,y);
  94.   inchar := get_char;
  95.   if (inchar = #$00) or (inchar = #$1F) then begin
  96.    inchar := get_char;
  97.    {IBM,   TI, WANG    ==>  WordSTAR  keyboard translator}
  98.    case inchar of
  99.     #75,       #195 : inchar := ^S;
  100.     #77,       #193 : inchar := ^D;
  101.     #71, #139, #211 : inchar := ^A;
  102.     #79, #138, #209 : inchar := ^F;
  103.     #83,       #199 : inchar := ^G;
  104.     #68, #56 , #215 : inchar := ^Y;
  105.     #72,       #192 : inchar := ^E;
  106.     #80,       #194 : inchar := ^X;
  107.     #73, #136, #208 : inchar := ^T;
  108.     #81, #137, #210 : inchar := ^B;
  109.     #59,       #128 : inchar := ^C;
  110.     #60,       #129 : inchar := ^L;
  111.     #61,       #200 : inchar := ^J;
  112.     #62,       #201 : inchar := ^K;
  113.     #82,       #198 : inchar := ^V;
  114.                #224 : inchar := #27;
  115.    end;
  116.   end;
  117.   case inchar of
  118.    #32..#126 : if position < l then
  119.                             begin
  120.                              position := position + 1;
  121.                              if (not ins) and (position <= length(s)) then begin
  122.                               s[position] := inchar;
  123.                              end
  124.                              else begin
  125.                              if length(s) = l then
  126.                              delete(s,l,1);
  127.                              insert(inchar,s,position);
  128.                              end;
  129.                              write(copy(s,position,l));
  130.                             end
  131.                             else begin
  132.                              error(1,5,' No additional characters allowed ');
  133.                              reverse_on;
  134.                             end;
  135.           ^S : if position > 0 then
  136.                     position := position - 1
  137.                else begin
  138.                 error(1,5,' Cannot move further LEFT ');
  139.                 reverse_on;
  140.                end;
  141.           ^D : if position < length(s) then
  142.                     position := position + 1
  143.                else begin
  144.                 error(1,5,' Cannot move further RIGHT ');
  145.                 reverse_on;
  146.                end;
  147.           ^A : position := 0;
  148.           ^F : position := length(s);
  149.           ^G : if position < length(s) then
  150.                begin
  151.                 delete(s,position+1,1);
  152.                 write(copy(s,position+1,l),underscore);
  153.                end;
  154.      ^H,#127 : if position > 0 then
  155.                begin
  156.                 delete(s,position,1);
  157.                 write(^H,copy(s,position,l),underscore);
  158.                 position := position - 1;
  159.                end
  160.                else begin
  161.                 error(1,5,' No character to delete ');
  162.                 reverse_on;
  163.                end;
  164.           ^Y : begin
  165.                 write(fillstring(underscore,length(s)-position));
  166.                 delete(s,position+1,l);
  167.                end;
  168.           ^V : begin
  169.                ins := not ins;
  170.                gotoxy(73,24);
  171.                if (ins) then write('INS') else write('OVR');
  172.                end;
  173.   else
  174.    if not(inchar in term) then begin
  175.     error(1,5,' Not a valid command ');
  176.     reverse_on;
  177.    end;
  178.   end;
  179.  until inchar in term;
  180.  position := length(s);
  181.  gotoxy(x+position,y);
  182.  write('':l-position);
  183.  tc := inchar;
  184.  reverse_off;
  185. end;
  186.  
  187. function integer_check(var input_string : str80;capstr,rjustify,fc : char;fw : integer): boolean;
  188. var testnum    : integer;
  189.     error_code : integer;
  190. begin
  191.  integer_check := false;
  192.  if (answer in [#27,^E]) then integer_check := true else begin
  193.   if (upcase(capstr) = 'Y') then capitalize(input_string);
  194.   if (upcase(rjustify) = 'Y') then input_string := rjust(input_string,fc,fw);
  195.   val(input_string,testnum,error_code);
  196.   if (error_code <> 0) then begin
  197.    input_String := '';
  198.    error(1,5,' Input is not Numeric ') end else
  199.   if (input_string = '') then begin
  200.    error(1,5,' Input to this field is MANDATORY ');
  201.   end else integer_check := true;
  202.  end;
  203. end;
  204.  
  205. function real_check(var input_string : str80;capstr,rjustify,fc : char;fw : integer): boolean;
  206. var testnum    : real;
  207.     error_code : integer;
  208. begin
  209.  real_check := false;
  210.  if (answer in [#27,^E]) then real_check := true else begin
  211.   if (upcase(capstr) = 'Y') then capitalize(input_string);
  212.   if (upcase(rjustify) = 'Y') then input_string := rjust(input_string,fc,fw);
  213.   val(input_string,testnum,error_code);
  214.   if (error_code <> 0) then begin
  215.    input_string := '';
  216.    error(1,5,' Input is not Numeric ') end else
  217.   if (input_string = '') then begin
  218.    error(1,5,' Input to this field is MANDATORY ');
  219.   end else if (pos('.',input_string) = 0) then begin
  220.    input_string := '';
  221.    error(1,7,' The real number you have entered has no DECIMAL POINT ')
  222.   end else real_check := true;
  223.  end;
  224. end;
  225.  
  226. function string_check(var input_string : str80;capstr,rjustify,fc : char;fw : integer): boolean;
  227. begin
  228.  string_check := false;
  229.  if (answer in [#27,^E]) then string_check := true else
  230.  if (input_string = '') then error(1,5,' Input to this field is MANDATORY ') else begin
  231.   if (upcase(capstr) = 'Y') then capitalize(input_string);
  232.   if (upcase(rjustify) = 'Y') then input_string := rjust(input_string,fc,fw);
  233.   string_check := true;
  234.  end;
  235. end;
  236.  
  237. function list_check(var input_string : str80;list : str80;
  238.                         supperr,capstr,rjustify,fc : char;fw : integer): boolean;
  239. var done   : boolean;
  240.     found  : boolean;
  241.     p2     : integer;
  242.     wlist  : str80;
  243. begin
  244.  list_check := false;
  245.  if (answer in [#27,^E]) then list_check := true else begin
  246.   if (upcase(capstr) = 'Y') then capitalize(input_string);
  247.   if (upcase(rjustify) = 'Y') then input_string := rjust(input_string,fc,fw);
  248.   if (input_string = '') then error(1,5,' Input to this field is MANDATORY ') else
  249.   begin
  250.    p2 := 1;
  251.    done := false;
  252.    found := false;
  253.    wlist := list;
  254.    repeat
  255.     p2 := pos(',',wlist);
  256.     if (p2 = 0) then begin p2 := length(wlist)+1;done := true;end;
  257.     if (input_string = copy(wlist,1,p2-1)) then begin
  258.       list_check := true;
  259.       found := true;
  260.       done := true;
  261.     end else delete(wlist,1,p2);
  262.    until done;
  263.    if not (found) and (supperr = 'N') then begin
  264.      input_string := '';
  265.      error(1,7,concat(' Valid options are: ',list));
  266.    end;
  267.   end;
  268.  end;
  269. end;
  270.  
  271. function num_check(var input_string : str80;capstr,rjustify,fc : char;fw : integer): boolean;
  272. var testnum    : real;
  273.     error_code : integer;
  274. begin
  275.  num_check := false;
  276.  if (answer in [#27,^E]) then num_check := true else begin
  277.   if (upcase(capstr) = 'Y') then capitalize(input_string);
  278.   if (upcase(rjustify) = 'Y') then input_string := rjust(input_string,fc,fw);
  279.   val(input_string,testnum,error_code);
  280.   if (error_code <> 0) then begin
  281.    input_string := '';
  282.    error(1,5,' Input is not Numeric ') end else
  283.   if (testnum = 0) then begin
  284.    input_string := '';
  285.    error(1,5,' Input to this field is MANDATORY ');
  286.   end else num_check := true;
  287.  end;
  288. end;